;;; mozremote.el --- Library for interacting with mozremote Firefox extention.

;; Copyright 2006 Lukas Loehrer
;; Based partly on js-mode.el by Helmut Eller
;;
;; Author: loehrerl [at] gmx [dot] net
;; Version: $Id: moz-remote.el,v 0.0 2006/08/06 07:28:22 luke Exp $
;; Keywords: 
;; X-URL: not distributed yet

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; if not, write to the Free Software
;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

;;; Commentary:
;;;
;;;This file implements the low level communication with the mozremote
;;;Firefox extension. The following functions are interesting for
;;;clients:
;;;
;;;mozremote-connect
;;;mozremote-call
;;;mozremote-call-sync
;;;
;;;mozremote-dictionary-get
;;;mozremote-dictionary-set
;;;mozremote-dictionary-for-each-entry
;;;mozremote-array-get
;;;mozremote-array-set
;;;
;;;mozremote-log-event
;;;
;;;See the docstrings and file mozremote-tests.el for examples on how
;;;to call these methods

;;; Code:

(provide 'mozremote)
(eval-when-compile
  (require 'cl))

;;{{{Required libraries

(require 'json)
(require 'pp)

;;}}}

(defconst EXIT-SUCCESS 0)

;;{{{ Networking

(defvar mozremote-hostname "localhost"
  "*Hostname where Firefox is running. This is mainly for debugging.")

(defvar mozremote-mozilla-connection nil)

(defvar mozremote-received-message-count 0
  "Counts the number of received messages from Firefox durring the currently active connection.")

(defvar mozremote-message-body-coding-system 'utf-8
  "Coding system used for message bodies.")

(defvar mozremote-connect-hook nil
  "Run after connection to mozilla has been established.")

(add-hook 'mozremote-connect-hook 'mozremote-reset-local-state)

(defun mozremote-reset-local-state ()
  "Reset local state variables."
  (setq mozremote-continuations nil)
  (setq mozremote-wait-tags nil)
  (setq mozremote-received-message-count 0))

(defun mozremote-connect (port)
  "Connect to Mozilla on PORT."
  (interactive (list (read-from-minibuffer "Port: " "7878" nil t)))
  (let ((socket (mozremote-net-connect port)))
    (setq mozremote-mozilla-connection socket)
	(run-hooks 'mozremote-connect-hook)
    ;; (mozremote-eval `(mozilla_info) (lambda (info) 
;; 									   (message "Connected to: %s" (car info))))
					 ))

(defun mozremote-disconnect ()
  "Close the connection to Mozilla."
  (interactive)
  (delete-process mozremote-mozilla-connection)
  (setq mozremote-mozilla-connection nil))

(defun mozremote-connected-p ()
  "Return t if connection to mozilla is up."
  (not (null mozremote-mozilla-connection)))

(defun mozremote-connection ()
  (when (not mozremote-mozilla-connection)
    (error "Not connected"))
  mozremote-mozilla-connection)

(defun mozremote-make-net-buffer (name)
  "Make a buffer suitable for a network process."
  (let ((buffer (generate-new-buffer name)))
    (with-current-buffer buffer
      (when (fboundp 'set-buffer-multibyte)
	(set-buffer-multibyte nil))
      (buffer-disable-undo))
    buffer))

(defun mozremote-net-connect (port)
  (let* ((socket (open-network-stream "Mozilla" nil mozremote-hostname port))
	 (buffer (mozremote-make-net-buffer "*mozilla*")))
    (set-process-buffer socket buffer)
    (set-process-filter socket 'mozremote-net-filter)
    (set-process-sentinel socket 'mozremote-net-sentinel)
	(with-current-buffer buffer
	  (set-buffer-multibyte t))
	(set-process-coding-system socket 'no-conversion 'no-conversion)
	(when (fboundp 'set-process-filter-multibyte)
	  (set-process-filter-multibyte socket t))
    socket))

(defun mozremote-net-send (string connection)
  (let ((string (concat (mozremote-net-encode-length (length string)) string)))
    (process-send-string connection (string-make-unibyte string))))

(defun mozremote-net-encode-length (n)
  (format "%06x" n))

(defun mozremote-net-filter (process string)
  "Accept output from the socket and input all complete messages.

Assume that no coding system conversion has been performed on STRING yet.
Thus it is regarded as a sequence of bytes."
  ;; The following seems to be necessary in emacs 21 because STRING is
  ;; unibyte. I am not sure if this is the correct way to do the conversion.
  (unless (multibyte-string-p string)
	(setq string (string-as-multibyte string))
	(setq string (decode-coding-string string 'binary)))
  (mozremote-log-event (list 'filter-call (multibyte-string-p string) string))
  (with-current-buffer (process-buffer process)
    (save-excursion
      (goto-char (point-max))
      (insert string))
    (goto-char (point-min))
    (mozremote-process-available-input)))

(defun mozremote-process-available-input ()
  "Process all complete messages that have arrived from Mozilla."
  (unwind-protect
      (when (mozremote-connection)
	(with-current-buffer (process-buffer (mozremote-connection))
	  (while (mozremote-net-have-input-p)
	    (let ((msg-body
			   (condition-case error
				   (mozremote-net-read)
				 (error (mozremote-net-panic error)))))
		  (mozremote-log-event (list 'message-body msg-body))
		  (let ((event (mozremote-unserialize msg-body)))
			(save-current-buffer
			  (mozremote-dispatch-message event))))))
    (when (mozremote-connection)
      (with-current-buffer (process-buffer (mozremote-connection))
	(when (mozremote-net-have-input-p)
	  (run-at-time 0 nil 'mozremote-process-available-input)))))))

(defun mozremote-net-panic (error)
  (message "net-read error: %S" error)
  (let ((string (buffer-string)))
    (ignore-errors
      (mozremote-disconnect)
      (kill-buffer (current-buffer)))
    (ding)
    (sleep-for 2)
    (with-current-buffer (generate-new-buffer "*saved-connecton-buffer*")
      (insert string)
      (error "PANIC!" error))))

(defun mozremote-net-have-input-p ()
  "Return true if a complete message is available."
  (and (>= (buffer-size) 6)
       (>= (- (buffer-size) 6) (mozremote-net-read-length))))

(defun mozremote-net-read-length ()
  (string-to-number (buffer-substring (point) (+ (point) 6)) 16))

(defun mozremote-net-read ()
  (let* ((length (mozremote-net-read-length))
	 (start (+ 6 (point)))
         (end (+ start length)))
	(mozremote-log-event (list 'net-read length start end (buffer-size)))
	(when (coding-system-p mozremote-message-body-coding-system)
	  (setq end (+ start (decode-coding-region start end mozremote-message-body-coding-system))))
    (let ((string (buffer-substring start end)))
      (prog1 string
        (delete-region (point-min) end)))))

(defun mozremote-net-sentinel (process message)
  (message "Mozilla connection closed unexpectedly: %s" message)
  (when (eq process mozremote-mozilla-connection)
    (setq mozremote-mozilla-connection nil))
  (kill-buffer (process-buffer process)))

(defun mozremote-send (term)
  (mozremote-log-event (list 'send term))
  (mozremote-net-send (mozremote-serialize term) (mozremote-connection)))

;;}}}
;;{{{Logging

(defvar mozremote-log-events t
  "*Log protocol events to the *mozremote-events* buffer.")
 
(defvar mozremote-log-buffer-name "*mozremote-events*"
  "The name of the js event buffer.")

(defun mozremote-log-event (event)
  "Record the fact that EVENT occurred."
  (when mozremote-log-events
    (with-current-buffer (mozremote-events-buffer)
      ;; trim?
      (when (> (buffer-size) 100000)
        (goto-char (/ (buffer-size) 2))
        (re-search-forward "^(" nil t)
        (delete-region (point-min) (point)))
      (goto-char (point-max))
      (save-excursion
        (mozremote-pprint-event event (current-buffer)))
      (goto-char (point-max)))))

(defun mozremote-pprint-event (event buffer)
  "Pretty print EVENT in BUFFER with limited depth and width."
  (let ((print-length 20)
		(print-level 6)
		(pp-escape-newlines t))
    (pp (list (format-time-string "%Y-%m-%dT%T") event) buffer)))

(defun mozremote-events-buffer ()
  (let ((buffer (get-buffer mozremote-log-buffer-name)))
	(if buffer
		buffer
	  (prog1
		  (setq buffer (get-buffer-create mozremote-log-buffer-name))
		(set-buffer buffer)
		(buffer-disable-undo)
		(set-buffer-multibyte t)))))
		

;;}}}
;;{{{Browser event handling

;; It works like this:
;; 
;; A handler can be installed to listen for events by a particular
;; service. Dispatch can then happen in the handler according to the
;; SPEC argument. Additional information are in the ARGS argument.


(defvar mozremote-event-handler-alist nil
  "Maps service names to a list of event handlers for this service.")

(defsubst mozremote-get-event-handlers (service)
  "Get event handlers for SERVICE."
  (cdr
   (assoc service  mozremote-event-handler-alist)))
  
(defun mozremote-handle-event-message (message)
  "Handle js-event messages from firemacs."
  (let ((service (mozremote-dictionary-get 'service message))
		(spec (mozremote-dictionary-get 'spec message)))
	(let ((handlers
		   (mozremote-get-event-handlers service)))
	  (if handlers
		  (let ((args (mozremote-dictionary-get 'args message)))
			(dolist (handler handlers)
			  (funcall handler service spec args)))
		(mozremote-log-event (format "No handler for service: %s" service))))))

(defun mozremote-event-add-handler (service handler)
  "Register HANDLER for events emitted by SERVICE."
  (let* ((key service)
		 (entry (assoc key mozremote-event-handler-alist)))
	(if entry
		(unless (member handler (cdr entry))
		  (push handler (cdr entry)))
		  (progn
	  (setq entry (cons key (list handler)))
	  (push entry mozremote-event-handler-alist)))))


(defun mozremote-event-remove-handler (service handler)
  "Remove HANDLER for events emitted by SERVICE."
  (let* ((key service)
		 (entry (assoc key mozremote-event-handler-alist)))
	(when entry
	  (setcdr entry (delete handler (cdr entry))))))

(defun mozremote-event-remove-all-handlers (service)
  "Remove all event handlers for SERVICE."
  (let ((key service))
	(setq mozremote-event-handler-alist
		  (let (alist)
			(dolist (entry mozremote-event-handler-alist)
			  (if (equal key (car entry))
				  (push entry alist)))
			alist))))

;;}}}
;;{{{Serialization 

;;{{{Dictionaries are alists with symbols as keys

(defmacro mozremote-dictionary-for-each-entry  (key value dict &rest body)
  "Loop over dictionary entries and do body with eatch entry."
`(loop for entry in ,dict do
	   (let ((,key (first entry))
			 (,value (rest entry)))
		 ,@body)))


(defmacro mozremote-dictionary-do  (key value dict &rest body)
  "Loop over dictionary entries and do body with eatch entry.

This version assumes dictionaries to be alists."
`(loop for (,key . ,value) in ,dict do
		 ,@body))

(defsubst mozremote-dictionary-get (key dictionary)
  "Encapsulate dictionary access.

Assumes dictionarys are alists, with symbols as keys."
  (cdr (assq key dictionary)))

(defsubst mozremote-dictionary-set (key value dictionary)
  "Encapsulate setting a dictionary element.

Assumes that dictionaries are alists with symbols as keys."
  (let ((pair (assq key dictionary)))
	(if pair
		(setcdr pair value)
	  (push (cons key value)  dictionary))))

(defmacro mozremote-dictionary-with (dict spec &rest body)
  "Quickly extract some values from a dictionary."
  `(let
	   ,(loop for entry in spec collect
			   (destructuring-bind (var name)
				   (if (listp entry)
					   entry
					 (list entry entry))
				 `(,var (mozremote-dictionary-get (quote ,name) ,dict))))
	   ,@body))


;;}}}

(defconst mozremote-array-format 'vector
  "This constatn is supposed to indicate what the format of javascript arrays is in emacs.

Possible values are 'list and 'vector. I have not foudn a good way yet to use this constant in order
to have the correct functions compiled automatically.")

;; The following block is commented out
;;{{{Arrays are lisp lists

;; (defmacro mozremote-array-do (element array &rest body)
;;   "Execute body for each element of ARRAY."
;;   `(loop for ,element in ,array do ,@body))

;; (defsubst mozremote-array-get (index array)
;;   "Encapsulate array access.

;; This version assumes that arrays are lists."
;;   (nth index array))

;; (defsubst mozremote-array-set (index value array)
;;   "Encapsulate setting an array element.

;; Assumes that arrays are lisp lists."
;;   (setf (nth index array) value))


;; (defsubst mozremote-array-to-list (array)
;;   "Convert array to lisp list."
;;   array)

;;}}})

;;{{{Arrays are elisp vectors

(defmacro mozremote-array-do (element array &rest body)
  "Execute body for each element of ARRAY."
  `(loop for ,element across ,array do ,@body))

(defsubst mozremote-array-get (index array)
  "Encapsulate array access.

This version assumes that arrays are vectors."
  (aref array index))

(defsubst mozremote-array-set (index value array)
  "Encapsulate setting an array element.

Assumes that arrays are vectors."
  (aset array index value))

(defsubst mozremote-array-to-list (array)
  "Convert array to lisp list."
  (append array nil))

;;}}}

(defun mozremote-json-read-from-string (json-data)
  "Converts JSON encoded data back into a lisp data structure."
  (let ((json-object-type 'alist)
		(json-array-type 'list)
		(json-key-type 'symbol))
	(tones-generate 800 100 -12)
	(json-read-from-string json-data)))

(defun mozremote-json-encode (lisp-data)
  "Encodes lisp-data to its JSON string representation."
	(json-encode lisp-data))

(defun mozremote-read-lisp-data (lisp-data)
  "Reads lisp data from Firefox."
  (read lisp-data))

(defsubst mozremote-true-p   (value)
  "Return t if value is not the :json-false keyword."
  (not (eq value :json-false)))

(defalias 'mozremote-serialize 'mozremote-json-encode)
(defalias 'mozremote-unserialize 'mozremote-read-lisp-data)

;;}}}
;;{{{RPC callback handling

(defvar mozremote-continuations ()
  "An alist of (ID . FUNCTION) functions waiting for results.")

(defvar mozremote-continuation-counter 0
  "Counter to generate serial number for continuations.")
(defconst mozremote-message-handler-alist
  '(("js-return" . mozremote-return)
		("js-event" . mozremote-handle-event-message)
		("js-error" . mozremote-js-error))
  "Maps message types to handler functions.")

(defun mozremote-dispatch-message (msg)
  "Dispatch messages from mozilla to appropriate handlers."
  (mozremote-log-event (list 'dispatch msg))
  (incf mozremote-received-message-count)
  (let ((handler
		 (assoc
		  (mozremote-dictionary-get 'type msg)
		  mozremote-message-handler-alist)))
	(if handler
	  (funcall (cdr handler) msg)
	  (mozremote-log-event
	   (list 'dispatch-error
			 "Invalid message type." 
			 (mozremote-dictionary-get 'type msg))))))
		
(defun mozremote-buffer-for-eval (saved-buffer)
  (let ((alive (buffer-name saved-buffer)))
    (cond (alive saved-buffer)
	  (t (generate-new-buffer (format "*killed %s*" saved-buffer))))))
					 
(defun mozremote-return (msg)
  (let* ((call-id (mozremote-dictionary-get 'callID msg))
		 (cont (assoc call-id mozremote-continuations)))
	(cond
	 (cont
	  (setq mozremote-continuations (delete cont mozremote-continuations))
	  (funcall (cdr cont) msg))
	 (t
	  (error "Unexpected reply: %d" call-id)))))

(defvar mozremote-wait-tags ())


(defun mozremote-wait (wait-tag)
  (let ((mozremote-wait-tags (cons wait-tag mozremote-wait-tags))
		(debug-on-quit t)
		(inhibit-quit nil))
    (catch wait-tag
      (while t (accept-process-output nil 0 10000)))))

(defun mozremote-show-result (result)
  "A simple callback that just shows the result in the echo area."
  (message "%S" result))

(defun mozremote-with-buffer (cont &optional buffer)
  "Callback factory: executes cont in context of buffer.
Uses the current buffer by default."
  (lexical-let ((cont cont)
				(buffer (or buffer (current-buffer))))
	(lambda (result)
	  (with-current-buffer buffer
		(funcall cont result)))))

(defun mozremote-insert-result ()
  "A simple callback that just inserts the result into the current buffer at point."
  (mozremote-with-buffer (lambda (result) (print result (current-buffer)))))


;;}}}
;;{{{Public functions

(defun mozremote-call (return-handler service method &rest args)
  "Calls method of mozremote service with arguments args and passes the result to return-handler asynchronously.

This function returns immediately after the call message has been sent to Firefox."
  (let ((call-id (incf mozremote-continuation-counter))
		(cont   ;; define wrapper for return-handler
		 (lexical-let ((handler return-handler))
		   (lambda (msg)  ;; here is the point where the execution will start after the return message is received
			 (let (		(exit-status (mozremote-dictionary-get 'exitStatus msg))
							(result  (mozremote-dictionary-get 'result msg)))
				 (cond
				  ((and handler (equal exit-status "EXIT_SUCCESS"))
				   (funcall handler result))
	  ;;; TODO: handle errors
				  (t (mozremote-log-event (list 'return "Exit status indecates failure.")))))))))
	;; Push the wrapped handler onto the list of pending calls
	(push (cons call-id cont) mozremote-continuations)
	;; Send the actual call message to server
    (mozremote-send `(
					   (type . js-call)
					   (callID . ,call-id)
					   (args . (,service ,method ,args))))))


(defun mozremote-call-sync (service method &rest args)
  "Calls method in mozremote service with args as arguments.

This function waits till the result of the method execution returns from Firefox. The result is returned."
  (let* ((call-id (incf mozremote-continuation-counter))
		 (tag (gensym))
		 (cont 
		  (lexical-let (						(tag tag))
			(lambda (msg)
			  (let (		(exit-status (mozremote-dictionary-get 'exitStatus msg))
							(result  (mozremote-dictionary-get 'result msg)))
				(cond
				 ((equal exit-status "EXIT_SUCCESS")
				  (throw tag (list result)))
	  ;;; TODO: handle errors
				 (t
				  (mozremote-log-event (list 'return "Exit status indecates failure."))
				  (throw tag (list exit-status)))))))))
	(push (cons call-id cont) mozremote-continuations)
    (mozremote-send `(
					   (type . js-call)
					   (callID . ,call-id)
					   (args . (,service ,method ,args))))
	(destructuring-bind (value) (mozremote-wait tag)
value)))


(defmacro mozremote-do-with-result  (result spec buffer &rest body)
  "Call remote function and execute BODY with the result bound to RESULT.

SPEC is  of the form (service method &rest args).
Buffer is the current buffer  while executing BODY."
  (let ((cont (gensym "mozremote"))
		(buf (gensym "mozremote")))
	(destructuring-bind (service method &rest args) spec
	  `(let ((,cont
			  (lexical-let ((,buf ,buffer))
				(lambda (,result)
				  (with-current-buffer ,buf
					,@body)))))
		 (mozremote-call ,cont ,service ,method ,@args)))))
		   
;; (defun mozremote-call-sync (service method &rest args)
;;   "Call method of service synchronously."
;;   (let* (	 (tag (gensym))
;; 	 (unwind (lexical-let ((tag tag))
;; 		   (lambda (value)
;; 		     (unless (memq tag mozremote-wait-tags)
;; 		       (error "Wait-tag not active: %S." tag))
;; 		     (throw tag (list value))))))
;; 	(apply 'mozremote-call unwind service method args)
;;     (destructuring-bind (value) (mozremote-wait tag)
;; value)))


;;}}}

;;{{{  emacs local variables

;;; local variables:
;;; folded-file: t
;;; byte-compile-dynamic: t
;;; end:

;;}}}

;;; mozremote.el ends here
